home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / fools.lzh / extend-syntax.scm next >
Encoding:
Text File  |  1990-03-02  |  9.4 KB  |  337 lines
  1. ;;; extend.ss
  2. ;;; Copyright (C) 1987 R. Kent Dybvig
  3. ;;; Permission to copy this software, in whole or in part, to use this
  4. ;;; software for any lawful purpose, and to redistribute this software
  5. ;;; is granted subject to the restriction that all copies made of this
  6. ;;; software must include this copyright notice in full.
  7.  
  8. ;;; The basic design of extend-syntax is due to Eugene Kohlbecker.  See
  9. ;;; "E. Kohlbecker: Syntactic Extensions in the Programming Language Lisp",
  10. ;;; Ph.D.  Dissertation, Indiana University, 1986."  The structure of "with"
  11. ;;; pattern/value clauses, the method for compiling extend-syntax into
  12. ;;; Scheme code, and the actual implementation are due to Kent Dybvig.
  13.  
  14. (in-package 'extend-syntax)
  15. (provide 'extend-syntax)
  16.  
  17. (define id
  18.   (lambda (name access control)
  19.     (list name access control)))
  20. (define id-name car)
  21. (define id-access cadr)
  22. (define id-control caddr)
  23.  
  24. (define loop
  25.   (lambda ()
  26.     (box '())))
  27. (define loop-ids unbox)
  28. (define loop-ids! set-box!)
  29.  
  30. (define c...rs
  31.   `((car caar . cdar)
  32.     (cdr cadr . cddr)
  33.     (caar caaar . cdaar)
  34.     (cadr caadr . cdadr)
  35.     (cdar cadar . cddar)
  36.     (cddr caddr . cdddr)
  37.     (caaar caaaar . cdaaar)
  38.     (caadr caaadr . cdaadr)
  39.     (cadar caadar . cdadar)
  40.     (caddr caaddr . cdaddr)
  41.     (cdaar cadaar . cddaar)
  42.     (cdadr cadadr . cddadr)
  43.     (cddar caddar . cdddar)
  44.     (cdddr cadddr . cddddr)))
  45.  
  46. (define add-car
  47.   (lambda (access)
  48.     (let ([x (and (pair? access) (assq (car access) c...rs))])
  49.       (if x
  50.       `(,(cadr x) ,@(cdr access))
  51.       `(car ,access)))))
  52.  
  53. (define add-cdr
  54.   (lambda (access)
  55.     (let ([x (and (pair? access) (assq (car access) c...rs))])
  56.       (if x
  57.       `(,(cddr x) ,@(cdr access))
  58.       `(cdr ,access)))))
  59.  
  60. (define checkpat
  61.   (lambda (keys pat exp)
  62.     (let ([vars (let f ([x pat] [vars '()])
  63.           (cond
  64.            [(pair? x)
  65.             (if (and (pair? (cdr x))
  66.                  (eq? (cadr x) '...)
  67.                  (null? (cddr x)))
  68.             (f (car x) vars)
  69.             (f (car x) (f (cdr x) vars)))]
  70.            [(symbol? x)
  71.             (cond
  72.              [(memq x keys) vars]
  73.              [(or (eq? x 'with) (eq? x '...))
  74.               (error 'extend-syntax
  75.                  "invalid context for ~s in ~s"
  76.                  x exp)]
  77.              [else (cons x vars)])]
  78.            [else vars]))])
  79.       (let ([dupls (duplicates vars)])
  80.     (unless (null? dupls)
  81.       (error 'extend-syntax
  82.          "duplicate pattern variable name ~s in ~s"
  83.          (car dupls)
  84.          exp))))))
  85. (define parse
  86.   (lambda (keys pat acc cntl ids)
  87.     (cond
  88.      [(symbol? pat)
  89.       (if (memq pat keys)
  90.       ids
  91.       (cons (id pat acc cntl) ids))]
  92.      [(pair? pat)
  93.       (cons (id pat acc cntl)
  94.         (if (equal? (cdr pat) '(...))
  95.         (let ([x (gensym)])
  96.           (parse keys (car pat) x (id x acc cntl) ids))
  97.         (parse keys (car pat) (add-car acc) cntl
  98.                (parse keys (cdr pat) (add-cdr acc) cntl ids))))]
  99.      [else ids])))
  100.  
  101. (define pattern-variable?
  102.   (lambda (sym ids)
  103.     (memq sym (map id-name ids))))
  104.  
  105. (define gen
  106.   (lambda (keys exp ids loops qqlev)
  107.     (cond
  108.      [(lookup exp ids) =>
  109.                (lambda (id)
  110.              (add-control! (id-control id) loops)
  111.              (list 'unquote (id-access id)))]
  112.      [(not (pair? exp)) exp]
  113.      [else
  114.       (cond
  115.        [(and (syntax-match? '(quasiquote *) exp)
  116.          (not (pattern-variable? 'quasiquote ids)))
  117.     (list 'unquote
  118.           (list 'list
  119.             ''quasiquote
  120.             (make-quasi
  121.              (gen keys (cadr exp) ids loops
  122.               (if (= qqlev 0) 0 (+ qqlev 1))))))]
  123.        [(and (syntax-match? '(* *) exp)
  124.          (memq (car exp) '(unquote unquote-splicing))
  125.          (not (pattern-variable? (car exp) ids)))
  126.     (list 'unquote
  127.           (if (= qqlev 1)
  128.           (gen-quotes keys (cadr exp) ids loops)
  129.           (list 'list
  130.             (list 'quote (car exp))
  131.             (make-quasi
  132.              (gen keys (cadr exp) ids loops
  133.                   (- qqlev 1))))))]
  134.        [(and (eq? (car exp) 'with)
  135.          (not (pattern-variable? 'with ids)))
  136.     (unless (syntax-match? '(with ((* *) ...) *) exp)
  137.       (error 'extend-syntax "invalid 'with' form ~s" exp))
  138.     (checkpat keys (map car (cadr exp)) exp)
  139.     (list 'unquote
  140.           (gen-with keys
  141.             (map car (cadr exp))
  142.             (map cadr (cadr exp))
  143.             (caddr exp)
  144.             ids
  145.             loops))]
  146.        [(and (pair? (cdr exp)) (eq? (cadr exp) '...))
  147.     (let ([x (loop)])
  148.       (gen-cons (list 'unquote-splicing
  149.               (make-loop x (gen keys (car exp) ids
  150.                         (cons x loops) qqlev)))
  151.             (gen keys (cddr exp) ids loops qqlev)))]
  152.        [else
  153.     (gen-cons (gen keys (car exp) ids loops qqlev)
  154.           (gen keys (cdr exp) ids loops qqlev))])])))
  155.  
  156. (define gen-cons
  157.   (lambda (head tail)
  158.     (if (null? tail)
  159.     (if (syntax-match? '(unquote-splicing *) head)
  160.         (list 'unquote (cadr head))
  161.         (cons head tail))
  162.     (if (syntax-match? '(unquote *) tail)
  163.         (list head (list 'unquote-splicing (cadr tail)))
  164.         (cons head tail)))))
  165.  
  166. (define gen-with
  167.   (lambda (keys pats exps body ids loops)
  168.     (let ([temps (map (lambda (x) (gensym)) pats)])
  169.       `(let (,@(map (lambda (t e) `[,t ,(gen-quotes keys e ids loops)])
  170.             temps
  171.             exps))
  172.      ,@(let f ([ps pats] [ts temps])
  173.          (if (null? ps)
  174.          (let f ([pats pats] [temps temps] [ids ids])
  175.            (if (null? pats)
  176.                `(,(make-quasi (gen keys body ids loops 0)))
  177.                (f (cdr pats)
  178.               (cdr temps)
  179.               (parse '() (car pats) (car temps) '() ids))))
  180.          (let ([m (match-pattern '() (car ps))])
  181.            (if (eq? m '*)
  182.                (f (cdr ps) (cdr ts))
  183.                `((unless (syntax-match? ',m ,(car ts))
  184.                (error ',(car keys)
  185.                   "~s does not fit 'with' pattern ~s"
  186.                   ,(car ts)
  187.                   ',(car ps)))
  188.              ,@(f (cdr ps) (cdr ts)))))))))))
  189.  
  190. (define gen-quotes
  191.   (lambda (keys exp ids loops)
  192.     (cond
  193.      [(syntax-match? '(quote *) exp)
  194.       (make-quasi (gen keys (cadr exp) ids loops 0))]
  195.      [(syntax-match? '(quasiquote *) exp)
  196.       (make-quasi (gen keys (cadr exp) ids loops 1))]
  197.      [(pair? exp)
  198.       (let f ([exp exp])
  199.     (if (pair? exp)
  200.         (cons (gen-quotes keys (car exp) ids loops)
  201.           (f (cdr exp)))
  202.         (gen-quotes keys exp ids loops)))]
  203.      [else exp])))
  204.  
  205. (define lookup
  206.   (lambda (exp ids)
  207.     (let loop ([ls ids])
  208.       (cond
  209.        [(null? ls) #f]
  210.        [(equal? (id-name (car ls)) exp) (car ls)]
  211.        [(subexp? (id-name (car ls)) exp) #f]
  212.        [else (loop (cdr ls))]))))
  213.  
  214. (define subexp?
  215.   (lambda (exp1 exp2)
  216.     (and (symbol? exp1)
  217.      (let f ([exp2 exp2])
  218.        (or (eq? exp1 exp2)
  219.            (and (pair? exp2)
  220.             (or (f (car exp2))
  221.             (f (cdr exp2)))))))))
  222.  
  223. (define add-control!
  224.   (lambda (id loops)
  225.     (unless (null? id)
  226.       (when (null? loops)
  227.     (error 'extend-syntax "missing ellipsis in expansion"))
  228.       (let ([x (loop-ids (car loops))])
  229.     (unless (memq id x)
  230.       (loop-ids! (car loops) (cons id x))))
  231.       (add-control! (id-control id) (cdr loops)))))
  232.  
  233. (define make-loop
  234.   (lambda (loop body)
  235.     (let ([ids (loop-ids loop)])
  236.       (when (null? ids)
  237.     (error 'extend-syntax "extra ellipsis in expansion"))
  238.       (cond
  239.        [(equal? body (list 'unquote (id-name (car ids))))
  240.     (id-access (car ids))]
  241.        [(and (null? (cdr ids))
  242.          (syntax-match? '(unquote (* *)) body)
  243.          (eq? (cadadr body) (id-name (car ids))))
  244.     `(map ,(caadr body) ,(id-access (car ids)))]
  245.        [else
  246.     `(map (lambda ,(map id-name ids) ,(make-quasi body))
  247.           ,@(map id-access ids))]))))
  248.  
  249. (define match-pattern
  250.   (lambda (keys pat)
  251.     (cond
  252.      [(symbol? pat)
  253.       (if (memq pat keys)
  254.       (if (memq pat '(* \\ ...))
  255.           `(\\ ,pat)
  256.           pat)
  257.       '*)]
  258.      [(pair? pat)
  259.       (if (and (pair? (cdr pat))
  260.            (eq? (cadr pat) '...)
  261.            (null? (cddr pat)))
  262.       `(,(match-pattern keys (car pat)) ...)
  263.       (cons (match-pattern keys (car pat))
  264.         (match-pattern keys (cdr pat))))]
  265.      [else pat])))
  266.  
  267. (define make-quasi
  268.   (lambda (exp)
  269.     (if (and (pair? exp) (eq? (car exp) 'unquote))
  270.     (cadr exp)
  271.     (list 'quasiquote exp))))
  272.  
  273. (define make-clause
  274.   (lambda (keys cl x)
  275.     (cond
  276.      [(syntax-match? '(* * *) cl)
  277.       (let ([pat (car cl)] [fender (cadr cl)] [exp (caddr cl)])
  278.     (checkpat keys pat pat)
  279.     (let ([ids (parse keys pat x '() '())])
  280.       `((and (syntax-match? ',(match-pattern keys pat) ,x)
  281.          ,(gen-quotes keys fender ids '()))
  282.         ,(make-quasi (gen keys exp ids '() 0)))))]
  283.      [(syntax-match? '(* *) cl)
  284.       (let ([pat (car cl)] [exp (cadr cl)])
  285.     (checkpat keys pat pat)
  286.     (let ([ids (parse keys pat x '() '())])
  287.       `((syntax-match? ',(match-pattern keys pat) ,x)
  288.         ,(make-quasi (gen keys exp ids '() 0)))))]
  289.      [else
  290.       (error 'extend-syntax "invalid clause ~s" cl)])))
  291.  
  292. (define make-syntax
  293.   (let ([x (string->uninterned-symbol "x")])
  294.     (lambda (keys clauses)
  295.       (when (memq '... keys)
  296.     (error 'extend-syntax
  297.            "invalid keyword ... in keyword list ~s"
  298.            keys))
  299.       `(lambda ,x
  300.      (set! ,x (cons ',(car keys) ,x))
  301.      (cond ,@(map (lambda (cl) (make-clause keys cl x)) clauses)
  302.            (else (error ',(car keys) "invalid syntax ~s" ,x)))))))
  303.  
  304. (define-macro (extend-syntax keys . clauses)
  305.   (if (andmap symbol? keys)
  306.       `(define-macro ,(car keys) ,(make-syntax keys clauses))
  307.       (error 'extend-syntax "invalid keys ~s" keys)))
  308.  
  309. (define-macro (extend-syntax/code keys . clauses)
  310.   (if (andmap symbol? keys)
  311.       `(quote ,(make-syntax keys clauses))
  312.       (error "extend-syntax/code:  invalid keys ~s" keys)))
  313.  
  314. (define top-level:syntax-match?
  315.   (lambda (pat exp)
  316.     (or (eq? pat '*)
  317.     (eq? exp pat)
  318.     (and (pair? pat)
  319.          (cond
  320.           [(and (eq? (car pat) '\\)
  321.             (pair? (cdr pat))
  322.             (null? (cddr pat)))
  323.            (eq? exp (cadr pat))]
  324.           [(and (pair? (cdr pat))
  325.             (eq? (cadr pat) '...)
  326.             (null? (cddr pat)))
  327.            (let ([pat (car pat)])
  328.          (let f ([lst exp])
  329.            (or (null? lst)
  330.                (and (pair? lst)
  331.                 (syntax-match? pat (car lst))
  332.                 (f (cdr lst))))))]
  333.           [else
  334.            (and (pair? exp)
  335.             (syntax-match? (car pat) (car exp))
  336.             (syntax-match? (cdr pat) (cdr exp)))])))))
  337.